home *** CD-ROM | disk | FTP | other *** search
/ Tech Arsenal 1 / Tech Arsenal (Arsenal Computer).ISO / tek-02 / msortp.zip / MSORTP.PAS < prev    next >
Pascal/Delphi Source File  |  1993-02-05  |  44KB  |  1,480 lines
  1. {*********************************************************}
  2. {*                    MSORTP.PAS 5.40                    *}
  3. {*        Copyright (c) TurboPower Software 1993.        *}
  4. {*                 All rights reserved.                  *}
  5. {*********************************************************}
  6.  
  7. {$F-,V-,B-,S-,I-,R-,X+,A+}
  8. {$IFDEF Ver70}
  9.   {$Q-}
  10. {$ENDIF}
  11.  
  12. unit MSortP;
  13.   {-Merge sort unit. Requires TPW or BP7 (rmode, pmode, Windows)}
  14.  
  15. interface
  16.  
  17. uses
  18. {$IFDEF Windows}
  19.   WinTypes,
  20.   WinProcs,
  21. {$ENDIF}
  22. {$IFDEF DPMI}
  23.   WinApi,
  24. {$ENDIF}
  25.   Strings;
  26.  
  27. const
  28.   MinRecsPerRun = 4;    {Minimum number of records in run buffer}
  29.   MergeOrder = 5;       {Input files used at a time during merge, >=2, <=10}
  30.   MaxSelectors = 256;   {Maximum number of selectors allocated}
  31.   SwapThreshold = 64;   {RecLen at least this big causes pointer swap}
  32.   MedianThreshold = 16; {Sort size where median-of-three is used}
  33.  
  34. type
  35.   ElementIOProc = procedure;
  36.   ElementCompareFunc = function (var X, Y) : Boolean;
  37.   MergeNameFunc = function (Dest : PChar; MergeNum : Word) : PChar;
  38.  
  39.   MergeInfoRec =
  40.     record                       {Record returned by MergeInfo}
  41.       SortStatus   : Word;       {Predicted status of sort, assuming disk ok}
  42.       MergeFiles   : Word;       {Total number of merge files created}
  43.       MergeHandles : Word;       {Maximum file handles used}
  44.       MergePhases  : Word;       {Number of merge phases}
  45.       MaxDiskSpace : LongInt;    {Maximum peak disk space used}
  46.       HeapUsed     : LongInt;    {Heap space actually used}
  47.       SelectorCount: Word;       {Number of selectors allocated}
  48.       RecsPerSel   : Word;       {Records stored in each selector}
  49.     end;
  50.  
  51.   function MergeSort(MaxHeapToUse : LongInt;
  52.                      RecLen : Word;
  53.                      SendToSortEngine : ElementIOProc;
  54.                      Less : ElementCompareFunc;
  55.                      GetFromSortEngine : ElementIOProc;
  56.                      MergeName : MergeNameFunc) : Word;
  57.     {-Sorts elements of size RecLen. Uses no more than MaxHeapToUse
  58.       bytes of heap space. Elements are passed into MergeSort by the
  59.       user-defined SendToSortEngine routine. Elements are compared by
  60.       the user-defined Less routine. Sorted elements are passed back
  61.       to the program by the user-defined GetFromSortEngine routine.
  62.       When merge files must be used, the name and location of each
  63.       merge file is determined by the user-defined MergeName routine.
  64.       MergeSort returns a status code:
  65.                  0    success
  66.                  1    user abort
  67.                  8    insufficient memory to sort
  68.                 106   invalid input parameter
  69.                         (RecLen zero, MaxHeapToUse too small)
  70.                 204   invalid pointer returned by GlobalLock, or
  71.                         SelectorInc <> 8
  72.                 213   no elements available to sort
  73.                 214   more than 65535 merge files
  74.                else   DOS or Turbo Pascal error code}
  75.  
  76.   function PutElement(var X) : Boolean;
  77.     {-Submits an element to the sort system. Returns True if the record
  78.       is successfully submitted.}
  79.  
  80.   function GetElement(var X) : Boolean;
  81.     {-Returns next record in sorted order. Returns True while there are
  82.       more records to return. When it returns False, X is uninitialized.}
  83.  
  84.   function DefaultMergeName(Dest : PChar; MergeNum : Word) : PChar;
  85.     {-Returns a default name for each merge file (SORnnnnn.TMP)}
  86.  
  87.   procedure AbortSort;
  88.     {-Call this routine from Less, SendToSortEngine, or GetFromSortEngine
  89.       to abort the sort. The Less function must always return False
  90.       if it calls AbortSort.}
  91.  
  92.   function OptimumHeapToUse(RecLen : Word; NumRecs : LongInt) : LongInt;
  93.     {-Returns the optimum amount of heap space to sort NumRecs records
  94.       of RecLen bytes each. Less heap space causes merging; more heap
  95.       space is partially unused.}
  96.  
  97.   function MinimumHeapToUse(RecLen : Word) : LongInt;
  98.     {-Returns the absolute minimum heap that allows MergeSort to succeed}
  99.  
  100.   procedure MergeInfo(MaxHeapToUse : LongInt;
  101.                       RecLen : Word;
  102.                       NumRecs : LongInt;
  103.                       var MI : MergeInfoRec);
  104.     {-Predicts status and resource usage of a merge sort. See
  105.       MergeInfoRec above for the information returned. Returns
  106.       MI.MaxDiskSpace = -1 in the rare case where disk space analysis
  107.       cannot be performed.}
  108.  
  109.   {==================================================================}
  110.  
  111. implementation
  112.  
  113. type
  114.   OS =
  115.     record                            {Convenient typecast}
  116.       O : Word;
  117.       S : Word;
  118.     end;
  119.   PointerPtr = ^Pointer;              {Pointer to pointer}
  120.   ElementPtrFunc =
  121.     function (ElNum : LongInt) : Pointer; {Return address of given element}
  122.   SwapElementProc =
  123.     procedure (Pl, Pr : LongInt);     {Swap two elements}
  124.  
  125.   MergeWordArray =
  126.     array[1..MergeOrder] of Word;     {Handles of open merge files}
  127.   MergePtrArray =
  128.     array[1..MergeOrder] of Pointer;  {Used for managing head elements}
  129.   SelectorArray =
  130.     array[0..MaxSelectors-1] of Word; {Used for managing the run buffer}
  131.   PathArray =
  132.     array[0..79] of Char;             {Used for buffering a pathname}
  133.  
  134. var
  135.   SortStatus : Word;                  {Current status of sort}
  136.   TotalCount : LongInt;               {Total elements sorted}
  137.  
  138.   {Variables related to memory management}
  139.   Selectors : SelectorArray;          {Selectors for global work area}
  140.   SelectorCount : Word;               {Number of selectors allocated}
  141.   DSelectorCount : Word;              {Number of selectors for run data}
  142.   RecsPerSel : Word;                  {Number of records mapped by one selector}
  143.   RecsShr : Word;                     {SHR count corresponding to RecsPerSel}
  144.   RecsMask : Word;                    {AND mask corresponding to RecsPerSel}
  145.   RecordLen : Word;                   {Bytes in each data record}
  146.   RecordLenAlloc : Word;              {Bytes in each data record buffer}
  147.   SwapPointers : WordBool;            {True when swapping pointers}
  148.  
  149.   {Variables related to run sorting}
  150.   AllocatedRecs : LongInt;            {Total records allocated in global buffer}
  151.   RunCapacity : LongInt;              {Capacity (in records) of run buffer}
  152.   RunCount : LongInt;                 {Current number of records in run buffer}
  153.   RunElement : LongInt;               {Last run element passed back to user}
  154.   PivotPtr : Pointer;                 {Pointer to pivot record}
  155.   SwapPtr : Pointer;                  {Pointer to record swap area}
  156.   LessF : ElementCompareFunc;         {User less function}
  157.   ElementPtrF : ElementPtrFunc;       {Element pointer function}
  158.   SwapElementP : SwapElementProc;     {Swap element procedure}
  159.  
  160.   {Variables related to merging}
  161.   MergeNameF : MergeNameFunc;         {User merge filename function}
  162.   MergeFileCount : Word;              {Number of merge files created}
  163.   MergeFileMerged : Word;             {Index of last merge file merged}
  164.   MergeOpenCount : Word;              {Count of open merge files}
  165.   MergeBufSize : Word;                {Usable bytes in merge buffer}
  166.   MergeFileNumber : MergeWordArray;   {File number of each open merge file}
  167.   MergeFiles : MergeWordArray;        {File handles for merge files}
  168.   MergeSelectors : MergeWordArray;    {Selectors for each merge buffer}
  169.   MergeBytesLoaded : MergeWordArray;  {Count of bytes in each merge buffer}
  170.   MergeBytesUsed : MergeWordArray;    {Bytes used in each merge buffer}
  171.   MergePtrs : MergePtrArray;          {Current head elements in each merge buffer}
  172.   OutFile : Word;                     {Output file handle}
  173.   OutSelector : Word;                 {Selector for output buffer}
  174.   OutBytesUsed : Word;                {Number of bytes in output buffer}
  175.  
  176.   {$DEFINE UseAsm}                    {Undefine only for testing}
  177.  
  178. {$IFNDEF DPMI}
  179. {$IFNDEF Windows}
  180.   {Emulate a couple of memory allocation functions. These
  181.    work only if Bytes < 65511, which is always true here.
  182.    Requires the heap manager of TP6 or later.}
  183.  
  184.   const
  185.     gmem_Moveable = $0002;     { Allocate moveable memory }
  186.  
  187.   type
  188.     THandle = Word;
  189.  
  190.   function HeapFunc(Size : Word) : Integer; far;
  191.     {-Return nil pointer if insufficient memory}
  192.   begin
  193.     if Size <> 0 then
  194.       HeapFunc := 1;
  195.   end;
  196.  
  197.   function GlobalAlloc(Flags : Word; Bytes : Longint) : THandle;
  198.   var
  199.     Alloc : Longint;
  200.     P : Pointer;
  201.     SaveHeapError : Pointer;
  202.   begin
  203.     Alloc := Bytes+16;
  204.     if Alloc > 65527 then
  205.       GlobalAlloc := 0
  206.     else begin
  207.       SaveHeapError := HeapError;
  208.       HeapError := @HeapFunc;
  209.       GetMem(P, Alloc);
  210.       if P = nil then
  211.         GlobalAlloc := 0
  212.       else begin
  213.         GlobalAlloc := OS(P).S+1;
  214.         Pointer(Ptr(OS(P).S, 8)^) := P;
  215.         LongInt(Ptr(OS(P).S, 12)^) := Alloc;
  216.       end;
  217.       HeapError := SaveHeapError;
  218.     end;
  219.   end;
  220.  
  221.   function GlobalFree(H : THandle) : THandle;
  222.   var
  223.     Alloc : Longint;
  224.     P : Pointer;
  225.   begin
  226.     if H <> 0 then begin
  227.       dec(H);
  228.       P := Pointer(Ptr(H, 8)^);
  229.       Alloc := LongInt(Ptr(H, 12)^);
  230.       FreeMem(P, Alloc);
  231.     end;
  232.     GlobalFree := 0;
  233.   end;
  234. {$ENDIF}
  235. {$ENDIF}
  236.  
  237.   function CreateFile(FName : PChar; var Handle : Word) : Word; assembler;
  238.     {-Create a file, returning status code and open handle}
  239.   asm
  240.     push ds
  241.     lds dx,FName
  242.     mov ah,$3C
  243.     xor cx,cx
  244.     int $21
  245.     jc @Done
  246.     les di,Handle
  247.     mov es:[di],ax
  248.     xor ax,ax
  249. @Done:
  250.     pop ds
  251.   end;
  252.  
  253.   function OpenFile(FName : PChar; var Handle : Word) : Word; assembler;
  254.     {-Open file read-only, returning status code and open handle}
  255.   asm
  256.     push ds
  257.     lds dx,FName
  258.     mov ax,$3D00      {read only}
  259.     int $21
  260.     jc @Done
  261.     les di,Handle
  262.     mov es:[di],ax
  263.     xor ax,ax
  264. @Done:
  265.     pop ds
  266.   end;
  267.  
  268.   function BlockWriteFile(Handle : Word; var Buf; BufLen : Word) : Word; assembler;
  269.     {-Write buffer to file, returning status}
  270.   asm
  271.     push ds
  272.     mov bx,Handle
  273.     mov cx,BufLen
  274.     lds dx,Buf
  275.     mov ah,$40
  276.     int $21
  277.     jc  @Done
  278.     cmp ax,cx
  279.     mov ax,101   {disk full}
  280.     jne @Done
  281.     xor ax,ax
  282. @Done:
  283.     pop ds
  284.   end;
  285.  
  286.   function BlockReadFile(Handle : Word; var Buf;
  287.                          BufLen : Word; var Len : Word) : Word; assembler;
  288.     {-Read buffer from file, returning status and bytes read}
  289.   asm
  290.     push ds
  291.     mov bx,Handle
  292.     mov cx,BufLen
  293.     lds dx,Buf
  294.     mov ah,$3F
  295.     int $21
  296.     jc  @Done
  297.     les di,Len
  298.     mov es:[di],ax
  299.     xor ax,ax
  300. @Done:
  301.     pop ds
  302.   end;
  303.  
  304.   function CloseFile(Handle : Word) : Word; assembler;
  305.     {-Close file, returning status}
  306.   asm
  307.     mov bx,Handle
  308.     mov ah,$3E
  309.     int $21
  310.     jc @Done
  311.     xor ax,ax
  312. @Done:
  313.   end;
  314.  
  315.   function DeleteFile(FName : PChar) : Word; assembler;
  316.     {-Delete closed file, returning status}
  317.   asm
  318.     push ds
  319.     lds dx,FName
  320.     mov ah,$41
  321.     int $21
  322.     jc @Done
  323.     xor ax,ax
  324. @Done:
  325.     pop ds
  326.   end;
  327.  
  328.   function ElementPtrDirect(ElNum : LongInt) : Pointer; far;
  329.     {-Return pointer to given element in the global buffer}
  330.   {$IFDEF UseAsm}
  331.   assembler;
  332.   asm
  333.     mov ax,word ptr ElNum
  334.     mov dx,word ptr ElNum+2
  335.     mov si,ax                               {Save low word of ElNum}
  336.     mov cl,byte ptr RecsShr
  337.  
  338.     {The following stuff circumvents the use of a 32-bit shift}
  339.     cmp cl,8                                {RecordLenAlloc > 256 bytes?}
  340.     jb  @2                                  {Jump if so}
  341.     cmp cl,16                               {RecordLenAlloc = 1 byte?}
  342.     jne @1                                  {Jump if not}
  343.     mov ax,dx                               {RecordLenAlloc = 1 byte}
  344.     jmp @3
  345. @1: mov al,ah                               {RecordLenAlloc <= 256 bytes}
  346.     mov ah,dl
  347.     sub cl,8
  348. @2: shr ax,cl
  349.  
  350. @3: shl ax,1                                {ax = selector offset}
  351.     mov bx,ax                               {bx = offset into Selectors}
  352.     mov ax,RecsMask                         {ax = offset mask}
  353.     and ax,si                               {ax = OS(ElNum).O and RecsMask}
  354.     mul word ptr RecordLenAlloc             {ax = data offset}
  355.     mov dx,word ptr Selectors[bx]           {dx:ax = address}
  356.   end;
  357.   {$ELSE}
  358.   begin
  359.     ElementPtrDirect := Ptr(Selectors[ElNum shr byte(RecsShr)],
  360.                             (OS(ElNum).O and RecsMask)*RecordLenAlloc);
  361.   end;
  362.   {$ENDIF}
  363.  
  364.   function ElementPtrIndirect(ElNum : LongInt) : Pointer; far;
  365.     {-Return pointer to element, assuming that first four bytes
  366.       of buffer are another pointer}
  367.   {$IFDEF UseAsm}
  368.   assembler;
  369.   asm
  370.     mov ax,word ptr ElNum
  371.     mov dx,word ptr ElNum+2
  372.     mov si,ax
  373.     mov cl,byte ptr RecsShr
  374.     cmp cl,8
  375.     jb  @2
  376.     cmp cl,16
  377.     jne @1
  378.     mov ax,dx
  379.     jmp @3
  380. @1: mov al,ah
  381.     mov ah,dl
  382.     sub cl,8
  383. @2: shr ax,cl
  384. @3: shl ax,1
  385.     mov bx,ax
  386.     mov ax,RecsMask
  387.     and ax,si
  388.     mul word ptr RecordLenAlloc
  389.     mov di,ax
  390.     mov es,word ptr Selectors[bx]
  391.     les ax,es:[di]
  392.     mov dx,es
  393.   end;
  394.   {$ELSE}
  395.   begin
  396.     ElementPtrIndirect := PointerPtr(Ptr(Selectors[ElNum shr byte(RecsShr)],
  397.                                      (OS(ElNum).O and RecsMask)*RecordLenAlloc))^;
  398.   end;
  399.   {$ENDIF}
  400.  
  401.   procedure MoveElement(SPtr, DPtr : Pointer); assembler;
  402.     {-Move one element into another. Assumes SPtr <> DPtr}
  403.   asm
  404.     mov dx,ds
  405.     mov cx,RecordLen
  406.     lds si,SPtr
  407.     les di,DPtr
  408.     cld
  409.     shr cx,1
  410.     rep movsw
  411.     rcl cx,1
  412.     rep movsb
  413.     mov ds,dx
  414.   end;
  415.  
  416.   procedure SwapElementsDirect(Pl, Pr : LongInt); far;
  417.     {-Swap data of elements}
  418.   var
  419.     LPtr : Pointer;
  420.     RPtr : Pointer;
  421.   begin
  422.     LPtr := ElementPtrDirect(Pl);
  423.     RPtr := ElementPtrDirect(Pr);
  424.     MoveElement(LPtr, SwapPtr);
  425.     MoveElement(RPtr, LPtr);
  426.     MoveElement(SwapPtr, RPtr);
  427.   end;
  428.  
  429.   procedure SwapElementPtrs(Pl, Pr : LongInt); far;
  430.     {-Swap element pointers}
  431.   {$IFDEF UseAsm}
  432.   assembler;
  433.   asm
  434.     push word ptr Pl+2
  435.     push word ptr Pl
  436.     call ElementPtrDirect
  437.     push dx         {Save result}
  438.     push ax
  439.     push word ptr Pr+2
  440.     push word ptr Pr
  441.     call ElementPtrDirect
  442.     mov bx,ds
  443.     mov es,dx
  444.     mov di,ax       {es:di -> RPtr}
  445.     pop si
  446.     pop ds          {ds:si -> LPtr}
  447.     mov ax,es:[di]
  448.     mov dx,es:[di+2]
  449.     xchg ax,ds:[si]
  450.     xchg dx,ds:[si+2]
  451.     mov es:[di],ax
  452.     mov es:[di+2],dx
  453.     mov ds,bx
  454.   end;
  455.   {$ELSE}
  456.   var
  457.     LPtr : PointerPtr;
  458.     RPtr : PointerPtr;
  459.     TPtr : Pointer;
  460.   begin
  461.     LPtr := ElementPtrDirect(Pl);
  462.     RPtr := ElementPtrDirect(Pr);
  463.     TPtr := LPtr^;
  464.     LPtr^ := RPtr^;
  465.     RPtr^ := TPtr;
  466.   end;
  467.   {$ENDIF}
  468.  
  469.   procedure QuickSort(L, R : LongInt);
  470.     {-Non-recursive in-memory quicksort}
  471.   const
  472.     StackSize = 32;
  473.   type
  474.     Stack = array[1..StackSize] of LongInt;
  475.   var
  476.     Pl : LongInt;            {Left edge within partition}
  477.     Pr : LongInt;            {Right edge within partition}
  478.     PartitionLen : LongInt;  {Length of partition}
  479.     LPtr : Pointer;          {Three elements used to find median}
  480.     MPtr : Pointer;
  481.     RPtr : Pointer;
  482.     StackP : Integer;        {Stack pointer}
  483.     Lstack : Stack;          {Pending partitions, left edge}
  484.     Rstack : Stack;          {Pending partitions, right edge}
  485.   begin
  486.     {Initialize the stack}
  487.     StackP := 1;
  488.     Lstack[1] := L;
  489.     Rstack[1] := R;
  490.  
  491.     {Repeatedly take top partition from stack}
  492.     repeat
  493.  
  494.       {Pop the stack}
  495.       L := Lstack[StackP];
  496.       R := Rstack[StackP];
  497.       Dec(StackP);
  498.  
  499.       {Sort current partition}
  500.       repeat
  501.  
  502.         PartitionLen := R-L+1;
  503.         MPtr := ElementPtrF(L+(PartitionLen shr 1));
  504.         if PartitionLen >= MedianThreshold then begin
  505.           {Find median element of three, storing pointer in MPtr}
  506.           LPtr := ElementPtrF(L);
  507.           RPtr := ElementPtrF(R);
  508.           if LessF(LPtr^, MPtr^) then begin
  509.             if LessF(MPtr^, RPtr^) then
  510.               {MPtr is the pivot}
  511.             else if LessF(RPtr^, LPtr^) then
  512.               MPtr := LPtr
  513.             else
  514.               MPtr := RPtr;
  515.           end else if LessF(RPtr^, LPtr^) then begin
  516.             if LessF(MPtr^, RPtr^) then
  517.               MPtr := RPtr;
  518.           end else
  519.             MPtr := LPtr;
  520.         end;
  521.  
  522.         {Save the pivot element}
  523.         MoveElement(MPtr, PivotPtr);
  524.  
  525.         {Swap items in sort order around the pivot}
  526.         Pl := L;
  527.         Pr := R;
  528.         repeat
  529.           {$IFDEF UseAsm}
  530.           asm
  531. @0:         push word ptr Pl+2
  532.             push word ptr Pl
  533.             call dword ptr ElementPtrF
  534.             push dx
  535.             push ax
  536.             push word ptr PivotPtr+2
  537.             push word ptr PivotPtr
  538.             call dword ptr LessF
  539.             or al,al
  540.             jz @1
  541.             add word ptr Pl,1
  542.             adc word ptr Pl+2,0
  543.             jmp @0
  544. @1:         push word ptr Pr+2
  545.             push word ptr Pr
  546.             call dword ptr ElementPtrF
  547.             push word ptr PivotPtr+2
  548.             push word ptr PivotPtr
  549.             push dx
  550.             push ax
  551.             call dword ptr LessF
  552.             or al,al
  553.             jz @2
  554.             sub word ptr Pr,1
  555.             sbb word ptr Pr+2,0
  556.             jmp @1
  557. @2:       end;
  558.           {$ELSE}
  559.           while LessF(ElementPtrF(Pl)^, PivotPtr^) do
  560.             Inc(Pl);
  561.           while LessF(PivotPtr^, ElementPtrF(Pr)^) do
  562.             Dec(Pr);
  563.           {$ENDIF}
  564.  
  565.           {Check for user abort}
  566.           if SortStatus <> 0 then
  567.             Exit;
  568.  
  569.           if Pl = Pr then begin
  570.             {Reached the pivot}
  571.             Inc(Pl);
  572.             Dec(Pr);
  573.           end else if Pl < Pr then begin
  574.             {Swap elements around the pivot}
  575.             SwapElementP(Pl, Pr);
  576.             Inc(Pl);
  577.             Dec(Pr);
  578.           end;
  579.         until Pl > Pr;
  580.  
  581.         {Decide which partition to sort next}
  582.         if (Pr-L) < (R-Pl) then begin
  583.           {Left partition is bigger}
  584.           if Pl < R then begin
  585.             {Stack the request for sorting right partition}
  586.             Inc(StackP);
  587.             Lstack[StackP] := Pl;
  588.             Rstack[StackP] := R;
  589.           end;
  590.           {Continue sorting left partition}
  591.           R := Pr;
  592.         end else begin
  593.           {Right partition is bigger}
  594.           if L < Pr then begin
  595.             {Stack the request for sorting left partition}
  596.             Inc(StackP);
  597.             Lstack[StackP] := L;
  598.             Rstack[StackP] := Pr;
  599.           end;
  600.           {Continue sorting right partition}
  601.           L := Pl;
  602.         end;
  603.  
  604.       until L >= R;
  605.     until StackP <= 0;
  606.   end;
  607.  
  608.   procedure CreateNewMergeFile(var Handle : Word);
  609.     {-Create a new merge file}
  610.   var
  611.     FName : PathArray;
  612.   begin
  613.     if MergeFileCount = 65535 then begin
  614.       {Too many merge files}
  615.       SortStatus := 214;
  616.       Exit;
  617.     end;
  618.  
  619.     {Create new merge file}
  620.     inc(MergeFileCount);
  621.     SortStatus := CreateFile(MergeNameF(FName, MergeFileCount), Handle);
  622.     if SortStatus <> 0 then
  623.       dec(MergeFileCount);
  624.   end;
  625.  
  626.   procedure FlushOutBuffer;
  627.     {-Write the merge output buffer to disk}
  628.   begin
  629.     if OutBytesUsed <> 0 then
  630.       SortStatus := BlockWriteFile(OutFile, Mem[OutSelector:0], OutBytesUsed);
  631.   end;
  632.  
  633.   procedure StoreElement(ElPtr : Pointer);
  634.     {-Store element in the merge output buffer}
  635.   begin
  636.     if OutBytesUsed >= MergeBufSize then begin
  637.       FlushOutBuffer;
  638.       if SortStatus <> 0 then
  639.         Exit;
  640.       OutBytesUsed := 0;
  641.     end;
  642.     MoveElement(ElPtr, Ptr(OutSelector, OutBytesUsed));
  643.     inc(OutBytesUsed, RecordLen);
  644.   end;
  645.  
  646.   procedure StoreNewMergeFile;
  647.     {-Create a new merge file and store run buffer to it}
  648.   label
  649.     ExitPoint;
  650.   var
  651.     SelNum : Word;
  652.     BytesLeft : LongInt;
  653.     BytesToWrite : LongInt;
  654.     ElNum : LongInt;
  655.     TempStatus : Word;
  656.   begin
  657.     {Create new merge file}
  658.     CreateNewMergeFile(OutFile);
  659.     if SortStatus <> 0 then
  660.       Exit;
  661.  
  662.     if SwapPointers then begin
  663.       {Write the run buffer element by element using pointer indirection}
  664.       OutBytesUsed := 0;
  665.       OutSelector := Selectors[DSelectorCount];
  666.       for ElNum := 0 to RunCount-1 do begin
  667.         StoreElement(ElementPtrIndirect(ElNum));
  668.         if SortStatus <> 0 then
  669.           goto ExitPoint;
  670.       end;
  671.       FlushOutBuffer;
  672.  
  673.     end else begin
  674.       {Write the run buffer by blocks to the merge file}
  675.       BytesLeft := RunCount*RecordLen;
  676.       BytesToWrite := MergeBufSize;
  677.       SelNum := 0;
  678.       while BytesLeft > 0 do begin
  679.         OutSelector := Selectors[SelNum];
  680.         if BytesLeft < BytesToWrite then
  681.           BytesToWrite := BytesLeft;
  682.         SortStatus := BlockWriteFile(OutFile, Mem[OutSelector:0], BytesToWrite);
  683.         if SortStatus <> 0 then
  684.           BytesLeft := 0
  685.           {Note: all merge files are deleted in MergeSort}
  686.         else begin
  687.           dec(BytesLeft, BytesToWrite);
  688.           inc(SelNum);
  689.         end;
  690.       end;
  691.     end;
  692.  
  693. ExitPoint:
  694.     {Close merge file}
  695.     TempStatus := CloseFile(OutFile);
  696.     if SortStatus = 0 then
  697.       SortStatus := TempStatus;
  698.   end;
  699.  
  700.   procedure GetMergeElementPtr(M : Word);
  701.     {-Get pointer to next valid element of specified open merge file}
  702.   var
  703.     Len : Word;
  704.     TempStatus : Word;
  705.     FName : PathArray;
  706.   begin
  707.     if MergeBytesUsed[M] >= MergeBytesLoaded[M] then begin
  708.       {Try to load new data into buffer}
  709.       SortStatus := BlockReadFile(MergeFiles[M], Mem[MergeSelectors[M]:0],
  710.                                   MergeBufSize, Len);
  711.       if (SortStatus <> 0) or (Len < RecordLen) then begin
  712.         {Error reading file or end of file. Close and delete it}
  713.         TempStatus := CloseFile(MergeFiles[M]);
  714.         TempStatus := DeleteFile(MergeNameF(FName, MergeFileNumber[M]));
  715.         {Remove file from merge list}
  716.         if M <> MergeOpenCount then begin
  717.           MergeFileNumber[M] := MergeFileNumber[MergeOpenCount];
  718.           MergeFiles[M] := MergeFiles[MergeOpenCount];
  719.           MergeSelectors[M] := MergeSelectors[MergeOpenCount];
  720.           MergeBytesLoaded[M] := MergeBytesLoaded[MergeOpenCount];
  721.           MergeBytesUsed[M] := MergeBytesUsed[MergeOpenCount];
  722.           MergePtrs[M] := MergePtrs[MergeOpenCount];
  723.         end;
  724.         dec(MergeOpenCount);
  725.         Exit;
  726.       end;
  727.       MergeBytesLoaded[M] := Len;
  728.       MergeBytesUsed[M] := 0;
  729.     end;
  730.  
  731.     OS(MergePtrs[M]).O := MergeBytesUsed[M];
  732.     inc(MergeBytesUsed[M], RecordLen);
  733.   end;
  734.  
  735.   procedure OpenMergeFiles;
  736.     {-Open next group of merge files (up to MergeOrder of them)}
  737.   var
  738.     FName : PathArray;
  739.   begin
  740.     MergeOpenCount := 0;
  741.     while (MergeOpenCount < MergeOrder) and (MergeFileMerged < MergeFileCount) do begin
  742.       {MergeOpenCount counts the number of open merge files}
  743.       inc(MergeOpenCount);
  744.       {Open associated merge file}
  745.       inc(MergeFileMerged);
  746.       SortStatus := OpenFile(MergeNameF(FName, MergeFileMerged), MergeFiles[MergeOpenCount]);
  747.       if SortStatus <> 0 then begin
  748.         dec(MergeFileMerged);
  749.         dec(MergeOpenCount);
  750.         Exit;
  751.       end;
  752.       {File number of merge file}
  753.       MergeFileNumber[MergeOpenCount] := MergeFileMerged;
  754.       {Selector for merge file}
  755.       MergeSelectors[MergeOpenCount] := Selectors[MergeOpenCount-1];
  756.       {Number of bytes currently in merge buffer}
  757.       MergeBytesLoaded[MergeOpenCount] := 0;
  758.       {Number of bytes used in merge buffer}
  759.       MergeBytesUsed[MergeOpenCount] := 0;
  760.       {Save the segment of the merge pointer}
  761.       OS(MergePtrs[MergeOpenCount]).S := MergeSelectors[MergeOpenCount];
  762.       {Get the first element}
  763.       GetMergeElementPtr(MergeOpenCount);
  764.       if SortStatus <> 0 then
  765.         Exit;
  766.     end;
  767.   end;
  768.  
  769.   function GetNextElementIndex : Word;
  770.     {-Return merge index of next element in sorted order, nil if error or none}
  771.   {$IFDEF UseAsm}
  772.   assembler;
  773.   var
  774.     MinElPtr : Pointer;
  775.   asm
  776.     {Get out fast if 0 or 1 merge files left open}
  777.     xor ax,ax
  778.     mov cx,MergeOpenCount
  779.     jcxz @3
  780.     inc ax
  781.     cmp cx,2
  782.     jb @3
  783.  
  784.     {Assume first element is the least}
  785.     les di,dword ptr MergePtrs
  786.     mov word ptr MinElPtr,di
  787.     mov word ptr MinElPtr+2,es
  788.     mov bx,2
  789.  
  790.     {Loop to find minimum element}
  791. @1: push ax                            {save result}
  792.     push bx                            {save loop index}
  793.     shl bx,1
  794.     shl bx,1
  795.     les di,dword ptr MergePtrs[bx-4]
  796.     push es                            {save MergePtrs[M]}
  797.     push di
  798.     push es
  799.     push di
  800.     les di,MinElPtr
  801.     push es
  802.     push di
  803.     call dword ptr LessF
  804.     or al,al
  805.     pop di
  806.     pop es
  807.     pop bx
  808.     pop ax
  809.     jz @2
  810.     mov ax,bx
  811.     mov word ptr MinElPtr,di
  812.     mov word ptr MinElPtr+2,es
  813. @2: inc bx
  814.     cmp bx,MergeOpenCount
  815.     jbe @1
  816. @3:
  817.   end;
  818.   {$ELSE}
  819.   var
  820.     M : Word;
  821.     MinElPtr : Pointer;
  822.   begin
  823.     if MergeOpenCount = 0 then begin
  824.       {All merge streams are empty}
  825.       GetNextElementIndex := 0;
  826.       Exit;
  827.     end;
  828.  
  829.     {Assume first element is the least}
  830.     MinElPtr := MergePtrs[1];
  831.     GetNextElementIndex := 1;
  832.  
  833.     {Scan the other elements}
  834.     for M := 2 to MergeOpenCount do
  835.       if LessF(MergePtrs[M]^, MinElPtr^) then begin
  836.         GetNextElementIndex := M;
  837.         MinElPtr := MergePtrs[M];
  838.       end;
  839.   end;
  840.   {$ENDIF}
  841.  
  842.   procedure MergeFileGroup;
  843.     {-Merge the opened merge files into the output}
  844.   var
  845.     NextElementIndex : Word;
  846.     TempStatus : Word;
  847.     Done : WordBool;
  848.   begin
  849.     Done := False;
  850.     repeat
  851.       {Find index of minimum element}
  852.       NextElementIndex := GetNextElementIndex;
  853.       if SortStatus <> 0 then
  854.         Done := True
  855.       else if NextElementIndex = 0 then
  856.         Done := True
  857.       else begin
  858.         {Copy element to output}
  859.         StoreElement(MergePtrs[NextElementIndex]);
  860.         if SortStatus <> 0 then
  861.           Done := True
  862.         else
  863.           {Get the next element from its merge stream}
  864.           GetMergeElementPtr(NextElementIndex);
  865.       end;
  866.     until Done;
  867.  
  868.     {Flush and close the output file}
  869.     if SortStatus = 0 then
  870.       FlushOutBuffer;
  871.     TempStatus := CloseFile(OutFile);
  872.     if SortStatus = 0 then
  873.       SortStatus := TempStatus;
  874.   end;
  875.  
  876.   procedure PrimaryMerge;
  877.     {-Merge until there are no more than MergeOrder merge files left}
  878.   begin
  879.     OutSelector := Selectors[MergeOrder];
  880.     while (SortStatus = 0) and (MergeFileCount-MergeFileMerged > MergeOrder) do begin
  881.       {Open next group of MergeOrder files}
  882.       OpenMergeFiles;
  883.       if SortStatus = 0 then begin
  884.         {Create new output file}
  885.         CreateNewMergeFile(OutFile);
  886.         if SortStatus = 0 then begin
  887.           {Merge these files into the output}
  888.           OutBytesUsed := 0;
  889.           MergeFileGroup;
  890.         end;
  891.       end;
  892.     end;
  893.   end;
  894.  
  895.   procedure DeleteRemainingFiles;
  896.     {-Delete any remaining merge files. Needed only in case of error}
  897.   var
  898.     TempStatus : Word;
  899.     I : Word;
  900.     FName : PathArray;
  901.   begin
  902.     for I := MergeFileMerged+1 to MergeFileCount do
  903.       TempStatus := DeleteFile(MergeNameF(FName, I));
  904.   end;
  905.  
  906.   {$IFDEF Windows}
  907.   procedure AHIncr; far; external 'KERNEL' index 114;
  908.     {-Magic routine for getting the constant to add to scan >64K blocks}
  909.   {$ENDIF}
  910.  
  911.   function ValidateInput(RecLen : Word) : Word;
  912.     {-Validate the input parameters}
  913.   begin
  914.     {Validate SelectorInc (8 assumed throughout)}
  915.     {$IFDEF DPMI}
  916.     if SelectorInc <> 8 then begin
  917.       ValidateInput := 204;
  918.       Exit;
  919.     end;
  920.     {$ENDIF}
  921.     {$IFDEF Windows}
  922.     if Ofs(AHIncr) <> 8 then begin
  923.       ValidateInput := 204;
  924.       Exit;
  925.     end;
  926.     {$ENDIF}
  927.  
  928.     if RecLen = 0 then begin
  929.       ValidateInput := 106;
  930.       Exit;
  931.     end;
  932.  
  933.     ValidateInput := 0;
  934.   end;
  935.  
  936.   procedure FreeAllHandles;
  937.     {-Free all allocated memory (in handle format)}
  938.   var
  939.     SelNum : Word;
  940.   begin
  941.     if SelectorCount > 0 then
  942.       for SelNum := 0 to SelectorCount-1 do
  943.         GlobalFree(Selectors[SelNum]);
  944.   end;
  945.  
  946.   function HandlesToSelectors : Word;
  947.     {-Convert handles to selectors}
  948.   var
  949.     SelNum : Word;
  950.     SelectorP : Pointer;
  951.     TempSelectors : SelectorArray;
  952.   begin
  953.     {$IFDEF Windows}
  954.     for SelNum := 0 to SelectorCount-1 do begin
  955.       SelectorP := GlobalLock(Selectors[SelNum]);
  956.       if (SelectorP = nil) or (OS(SelectorP).O <> 0) then begin
  957.         FreeAllHandles;
  958.         HandlesToSelectors := 204;
  959.         Exit;
  960.       end;
  961.       TempSelectors[SelNum] := OS(SelectorP).S;
  962.     end;
  963.  
  964.     {All succeeded}
  965.     move(TempSelectors, Selectors, SelectorCount*SizeOf(Word));
  966.     {$ENDIF}
  967.     HandlesToSelectors := 0;
  968.   end;
  969.  
  970.   procedure SelectorsToHandles;
  971.   var
  972.     Handle : THandle;
  973.     SelNum : Word;
  974.   begin
  975.     {$IFDEF Windows}
  976.     for SelNum := 0 to SelectorCount-1 do begin
  977.       Handle := Selectors[SelNum];
  978.       GlobalUnlock(Handle);
  979.       Selectors[SelNum] := GlobalHandle(Handle);
  980.     end;
  981.     {$ENDIF}
  982.   end;
  983.  
  984.   procedure GetMaxRecsPerSel(RecLen : Word);
  985.     {-Compute maximum RecsPerSel and RecsShr for given RecLen}
  986.   var
  987.     R : LongInt;
  988.   begin
  989.     R := 1;
  990.     RecsShr := 0;
  991.     while R*RecLen < 65536 do begin
  992.       R := R shl 1;
  993.       inc(RecsShr);
  994.     end;
  995.     if RecsShr > 0 then begin
  996.       R := R shr 1;
  997.       dec(RecsShr);
  998.     end;
  999.     RecsPerSel := R;
  1000.   end;
  1001.  
  1002.   function GetHandles(RecLen : Word; MaxHeapToUse : LongInt) : Word;
  1003.     {-Compute segment sizes and allocate memory}
  1004.   var
  1005.     Handle : THandle;
  1006.     InitAvail : LongInt;
  1007.     SegmentSize : Word;
  1008.     TooMuchHeapUsed : WordBool;
  1009.   begin
  1010.     {Swap elements or pointers?}
  1011.     SwapPointers := (RecLen >= SwapThreshold) and
  1012.                     (RecLen <= 65535-SizeOf(Pointer));
  1013.  
  1014.     {Adjust for pointer swapping}
  1015.     RecordLen := RecLen;
  1016.     if SwapPointers then begin
  1017.       {Allocate an extra pointer for each record and swap just the pointers}
  1018.       RecordLenAlloc := RecordLen+SizeOf(Pointer);
  1019.       ElementPtrF := ElementPtrIndirect;
  1020.       SwapElementP := SwapElementPtrs;
  1021.     end else begin
  1022.       RecordLenAlloc := RecordLen;
  1023.       ElementPtrF := ElementPtrDirect;
  1024.       SwapElementP := SwapElementsDirect;
  1025.     end;
  1026.  
  1027.     {Compute largest power-of-two number of recs that fit into 64K}
  1028.     GetMaxRecsPerSel(RecordLenAlloc);
  1029.  
  1030.     {Search for valid combinations of selectors}
  1031.     repeat
  1032.       {Allocate as many handles as possible in memory given}
  1033.       SelectorCount := 0;
  1034.       InitAvail := MemAvail;
  1035.       repeat
  1036.         {Allocate next handle}
  1037.         Handle := GlobalAlloc(gmem_Moveable, RecsPerSel*RecordLenAlloc);
  1038.         Selectors[SelectorCount] := Handle;
  1039.         inc(SelectorCount);
  1040.         TooMuchHeapUsed := (InitAvail-MemAvail > MaxHeapToUse);
  1041.       until (SelectorCount = MaxSelectors) or (Handle = 0) or TooMuchHeapUsed;
  1042.  
  1043.       if TooMuchHeapUsed then begin
  1044.         {Deallocate last handle to keep within heap quota}
  1045.         Handle := GlobalFree(Handle);
  1046.         dec(SelectorCount);
  1047.         {If we fail, it's because MaxHeapToUse was too small}
  1048.         GetHandles := 106;
  1049.       end else if Handle = 0 then begin
  1050.         {Last handle wasn't allocated}
  1051.         dec(SelectorCount);
  1052.         {If we fail, it's because there was insufficient heap space}
  1053.         GetHandles := 8;
  1054.       end;
  1055.  
  1056.       if SelectorCount < MergeOrder+1 then begin
  1057.         {Not enough selectors, cut segment size in two}
  1058.         FreeAllHandles;
  1059.         RecsPerSel := RecsPerSel shr 1;
  1060.         dec(RecsShr);
  1061.       end;
  1062.     until (SelectorCount >= MergeOrder+1) or (RecsPerSel = 0);
  1063.  
  1064.     if RecsPerSel = 0 then
  1065.       {No way to get enough buffers}
  1066.       Exit;
  1067.  
  1068.     RecsMask := RecsPerSel-1;
  1069.     SegmentSize := RecsPerSel*RecordLenAlloc;
  1070.     MergeBufSize := (SegmentSize div RecordLen)*RecordLen;
  1071.  
  1072.     if SwapPointers then begin
  1073.       {Last segment reserved for sorted run output buffer}
  1074.       DSelectorCount := SelectorCount-1;
  1075.       AllocatedRecs := LongInt(RecsPerSel)*DSelectorCount;
  1076.       PivotPtr := ElementPtrDirect(AllocatedRecs-1);
  1077.       inc(OS(PivotPtr).O, SizeOf(Pointer));
  1078.       RunCapacity := AllocatedRecs-1;
  1079.     end else begin
  1080.       DSelectorCount := SelectorCount;
  1081.       AllocatedRecs := LongInt(RecsPerSel)*DSelectorCount;
  1082.       PivotPtr := ElementPtrDirect(AllocatedRecs-1);
  1083.       SwapPtr := ElementPtrDirect(AllocatedRecs-2);
  1084.       RunCapacity := AllocatedRecs-2;
  1085.     end;
  1086.  
  1087.     if RunCapacity < MinRecsPerRun then begin
  1088.       {No way to get enough memory in enough buffers}
  1089.       FreeAllHandles;
  1090.       Exit;
  1091.     end;
  1092.  
  1093.     GetHandles := 0;
  1094.   end;
  1095.  
  1096.   function MergeSort(MaxHeapToUse : LongInt;
  1097.                      RecLen : Word;
  1098.                      SendToSortEngine : ElementIOProc;
  1099.                      Less : ElementCompareFunc;
  1100.                      GetFromSortEngine : ElementIOProc;
  1101.                      MergeName : MergeNameFunc) : Word;
  1102.   begin
  1103.     {Validate input parameters}
  1104.     SortStatus := ValidateInput(RecLen);
  1105.  
  1106.     {Compute selector sizes and allocate buffers}
  1107.     if SortStatus = 0 then
  1108.       SortStatus := GetHandles(RecLen, MaxHeapToUse);
  1109.  
  1110.     {Convert handles to selectors}
  1111.     if SortStatus = 0 then
  1112.       SortStatus := HandlesToSelectors;
  1113.  
  1114.     {Get out if any error occurred}
  1115.     if SortStatus <> 0 then begin
  1116.       MergeSort := SortStatus;
  1117.       Exit;
  1118.     end;
  1119.  
  1120.     {Copy parameters to global variables and initialize other globals}
  1121.     LessF := Less;
  1122.     MergeNameF := MergeName;
  1123.     RunCount := 0;
  1124.     TotalCount := 0;
  1125.     MergeFileCount := 0;
  1126.     MergeFileMerged := 0;
  1127.  
  1128.     {Get all the elements from the user}
  1129.     SendToSortEngine;
  1130.     Inc(TotalCount, RunCount);
  1131.     if TotalCount = 0 then
  1132.       SortStatus := 213;
  1133.  
  1134.     if SortStatus = 0 then
  1135.       if RunCount > 0 then begin
  1136.         {Sort the last run buffer}
  1137.         QuickSort(0, RunCount-1);
  1138.         if MergeFileCount > 0 then
  1139.           {There's already a merge file, create another}
  1140.           StoreNewMergeFile;
  1141.       end;
  1142.  
  1143.     if SortStatus = 0 then
  1144.       if MergeFileCount > 0 then begin
  1145.         {Perform primary merging}
  1146.         PrimaryMerge;
  1147.         if SortStatus = 0 then
  1148.           {Open the last group of files}
  1149.           OpenMergeFiles;
  1150.       end else
  1151.         {Prepare to return elements from run buffer}
  1152.         RunElement := 0;
  1153.  
  1154.     if SortStatus = 0 then
  1155.       {Pass elements back to the user}
  1156.       GetFromSortEngine;
  1157.  
  1158.     {Assure all merge files are gone}
  1159.     DeleteRemainingFiles;
  1160.  
  1161.     {Free global data}
  1162.     SelectorsToHandles;
  1163.     FreeAllHandles;
  1164.  
  1165.     {Return status}
  1166.     MergeSort := SortStatus;
  1167.   end;
  1168.  
  1169.   function PutElement(var X) : Boolean;
  1170.   var
  1171.     SwapPtr : PointerPtr;
  1172.     DataPtr : Pointer;
  1173.   begin
  1174.     if SortStatus <> 0 then begin
  1175.       PutElement := False;
  1176.       Exit;
  1177.     end;
  1178.  
  1179.     if RunCount >= RunCapacity then begin
  1180.       {Sort run buffer}
  1181.       QuickSort(0, RunCount-1);
  1182.       {Store to merge file}
  1183.       StoreNewMergeFile;
  1184.       if SortStatus <> 0 then begin
  1185.         {File operation failed}
  1186.         PutElement := False;
  1187.         Exit;
  1188.       end;
  1189.       Inc(TotalCount, RunCount);
  1190.       RunCount := 0;
  1191.     end;
  1192.  
  1193.     {Store the element in the run buffer}
  1194.     if SwapPointers then begin
  1195.       SwapPtr := ElementPtrDirect(RunCount);
  1196.       DataPtr := Ptr(OS(SwapPtr).S, OS(SwapPtr).O+SizeOf(Pointer));
  1197.       SwapPtr^ := DataPtr;
  1198.     end else
  1199.       DataPtr := ElementPtrDirect(RunCount);
  1200.  
  1201.     MoveElement(@X, DataPtr);
  1202.     Inc(RunCount);
  1203.     PutElement := True;
  1204.   end;
  1205.  
  1206.   function GetElement(var X) : Boolean;
  1207.   var
  1208.     NextElementIndex : Word;
  1209.   begin
  1210.     if SortStatus <> 0 then
  1211.       GetElement := False
  1212.  
  1213.     else if MergeFileCount = 0 then begin
  1214.       {No merging required}
  1215.       if RunElement >= RunCount then
  1216.         {No more elements}
  1217.         GetElement := False
  1218.       else begin
  1219.         MoveElement(ElementPtrF(RunElement), @X);
  1220.         inc(RunElement);
  1221.         GetElement := True;
  1222.       end;
  1223.  
  1224.     end else begin
  1225.       {Get next merge element}
  1226.       NextElementIndex := GetNextElementIndex;
  1227.       if NextElementIndex = 0 then
  1228.         {No more elements or error}
  1229.         GetElement := False
  1230.       else begin
  1231.         {Return the element}
  1232.         MoveElement(MergePtrs[NextElementIndex], @X);
  1233.         {Get pointer to next element in the stream just used}
  1234.         GetMergeElementPtr(NextElementIndex);
  1235.         GetElement := True;
  1236.       end;
  1237.     end;
  1238.   end;
  1239.  
  1240.   function DefaultMergeName(Dest : PChar; MergeNum : Word) : PChar;
  1241.   var
  1242.     S : array[0..5] of Char;
  1243.   begin
  1244.     Str(MergeNum, S);
  1245.     DefaultMergeName := StrCat(StrCat(StrCopy(Dest, 'SOR'), S), '.TMP');
  1246.   end;
  1247.  
  1248.   procedure AbortSort;
  1249.   begin
  1250.     SortStatus := 1;
  1251.   end;
  1252.  
  1253.   function OptimumHeapToUse(RecLen : Word; NumRecs : LongInt) : LongInt;
  1254.   begin
  1255.     {Swap elements or pointers?}
  1256.     SwapPointers := (RecLen >= SwapThreshold) and
  1257.                     (RecLen <= 65535-SizeOf(Pointer));
  1258.     if SwapPointers then
  1259.       inc(RecLen, SizeOf(Pointer))
  1260.     else
  1261.       {Account for swap element}
  1262.       inc(NumRecs);
  1263.     {Account for pivot element}
  1264.     inc(NumRecs);
  1265.  
  1266.     {Compute largest power-of-two number of recs that fit into 64K}
  1267.     GetMaxRecsPerSel(RecLen);
  1268.  
  1269.     {Compute number of selectors}
  1270.     repeat
  1271.       SelectorCount := NumRecs div RecsPerSel;
  1272.       if NumRecs mod RecsPerSel <> 0 then
  1273.         inc(SelectorCount);
  1274.       if SwapPointers then
  1275.         {Last selector used for run output buffer when swapping pointers}
  1276.         inc(SelectorCount);
  1277.       if SelectorCount < MergeOrder+1 then
  1278.         RecsPerSel := RecsPerSel shr 1;
  1279.     until (SelectorCount >= MergeOrder+1) or (RecsPerSel = 0);
  1280.  
  1281.     if RecsPerSel = 0 then
  1282.       OptimumHeapToUse := -1
  1283.     else begin
  1284.       if SwapPointers then
  1285.         {Last segment reserved for merge output buffer}
  1286.         inc(SelectorCount);
  1287.       {Assume 32 byte overhead per selector and 2048 byte fixed overhead}
  1288.       OptimumHeapToUse := 2048+
  1289.                           SelectorCount*(LongInt(RecsPerSel)*RecLen+32);
  1290.     end;
  1291.   end;
  1292.  
  1293.   function MinimumHeapToUse(RecLen : Word) : LongInt;
  1294.   var
  1295.     MinHeapUsed : LongInt;
  1296.     HeapToUse : LongInt;
  1297.   begin
  1298.     {Swap elements or pointers?}
  1299.     SwapPointers := (RecLen >= SwapThreshold) and
  1300.                     (RecLen <= 65535-SizeOf(Pointer));
  1301.     if SwapPointers then
  1302.       inc(RecLen, SizeOf(Pointer));
  1303.  
  1304.     {Compute largest power-of-two number of recs that fit into 64K}
  1305.     GetMaxRecsPerSel(RecLen);
  1306.  
  1307.     {Try all valid RecsPerSel}
  1308.     MinHeapUsed := MaxLongInt;
  1309.     repeat
  1310.       {Try minimum number of selectors}
  1311.       SelectorCount := MergeOrder+1;
  1312.       repeat
  1313.         AllocatedRecs := LongInt(RecsPerSel)*SelectorCount;
  1314.         if SwapPointers then
  1315.           RunCapacity := AllocatedRecs-RecsPerSel-1
  1316.         else
  1317.           RunCapacity := AllocatedRecs-2;
  1318.         if RunCapacity < MinRecsPerRun then
  1319.           inc(SelectorCount);
  1320.       until RunCapacity >= MinRecsPerRun;
  1321.       HeapToUse := 2048+SelectorCount*(LongInt(RecsPerSel)*RecLen+32);
  1322.       if HeapToUse < MinHeapUsed then
  1323.         MinHeapUsed := HeapToUse;
  1324.       RecsPerSel := RecsPerSel shr 1;
  1325.     until RecsPerSel = 0;
  1326.  
  1327.     MinimumHeapToUse := MinHeapUsed;
  1328.   end;
  1329.  
  1330.   procedure MergeInfo(MaxHeapToUse : LongInt;
  1331.                       RecLen : Word;
  1332.                       NumRecs : LongInt;
  1333.                       var MI : MergeInfoRec);
  1334.   type
  1335.     MergeFileSizeArray = array[1..16383] of LongInt;
  1336.   var
  1337.     InitAvail : LongInt;
  1338.     RecordsLeft : LongInt;
  1339.     RecordsInFile : LongInt;
  1340.     DiskSpace : LongInt;
  1341.     OutputSpace : LongInt;
  1342.     PeakDiskSpace : LongInt;
  1343.     MFileCount : LongInt;
  1344.     RecsNeeded : LongInt;
  1345.     SizeBufSize : Word;
  1346.     MergeFileSizeP : ^MergeFileSizeArray;
  1347.   begin
  1348.     {Set defaults for the MergeInfoRec}
  1349.     FillChar(MI, SizeOf(MergeInfoRec), 0);
  1350.  
  1351.     {Validate input parameters}
  1352.     SortStatus := ValidateInput(RecLen);
  1353.     if SortStatus = 0 then
  1354.       if NumRecs = 0 then
  1355.         SortStatus := 213;
  1356.  
  1357.     {Compute selector sizes and allocate buffers}
  1358.     if SortStatus = 0 then begin
  1359.       InitAvail := MemAvail;
  1360.       SortStatus := GetHandles(RecLen, MaxHeapToUse);
  1361.     end;
  1362.  
  1363.     {Get out if sort is predicted to fail}
  1364.     if SortStatus <> 0 then begin
  1365.       MI.SortStatus := SortStatus;
  1366.       Exit;
  1367.     end;
  1368.  
  1369.     {Compute amount of memory used while getting handles}
  1370.     dec(InitAvail, MemAvail);
  1371.     MI.HeapUsed := InitAvail;
  1372.  
  1373.     {Deallocate the memory allocated by GetHandles}
  1374.     FreeAllHandles;
  1375.  
  1376.     RecsNeeded := NumRecs+1;
  1377.     if not SwapPointers then
  1378.       inc(RecsNeeded);
  1379.  
  1380.     if DSelectorCount*LongInt(RecsPerSel) >= RecsNeeded then begin
  1381.       {All the records fit into memory}
  1382.       MI.SelectorCount := SelectorCount;
  1383.       MI.RecsPerSel := RecsPerSel;
  1384.       Exit;
  1385.     end;
  1386.  
  1387.     {Store the information we already know}
  1388.     MI.SelectorCount := SelectorCount;
  1389.     MI.RecsPerSel := RecsPerSel;
  1390.  
  1391.     {Compute initial number of merge files and disk space}
  1392.     MFileCount := NumRecs div RunCapacity;
  1393.     if NumRecs mod RunCapacity <> 0 then
  1394.       inc(MFileCount);
  1395.     if MFileCount > 65535 then begin
  1396.       MI.SortStatus := 214;
  1397.       Exit;
  1398.     end;
  1399.     MergeFileCount := MFileCount;
  1400.     DiskSpace := NumRecs*RecordLen;
  1401.  
  1402.     {At least one merge phase required}
  1403.     MI.MergePhases := 1;
  1404.  
  1405.     if MergeFileCount <= MergeOrder then begin
  1406.       {Only one merge phase, direct to user}
  1407.       MI.MergeFiles := MergeFileCount;
  1408.       MI.MergeHandles := MergeFileCount;
  1409.       MI.MaxDiskSpace := DiskSpace;
  1410.       Exit;
  1411.     end;
  1412.  
  1413.     {Compute total number of merge files and merge phases}
  1414.     MergeFileMerged := 0;
  1415.     while MergeFileCount-MergeFileMerged > MergeOrder do begin
  1416.       inc(MI.MergePhases);
  1417.       MergeOpenCount := 0;
  1418.       while (MergeOpenCount < MergeOrder) and (MergeFileMerged < MergeFileCount) do begin
  1419.         inc(MergeOpenCount);
  1420.         inc(MergeFileMerged);
  1421.       end;
  1422.       inc(MergeFileCount);
  1423.     end;
  1424.  
  1425.     {Store the information we already know}
  1426.     MI.MergeFiles := MergeFileCount;
  1427.     MI.MergeHandles := MergeOrder+1; {MergeOrder input files, 1 output file}
  1428.  
  1429.     {Determine whether the disk space analysis can proceed}
  1430.     SizeBufSize := MergeFileCount*SizeOf(LongInt);
  1431.     if (MergeFileCount > 16383) or (MaxAvail < SizeBufSize) then begin
  1432.       MI.MaxDiskSpace := -1;
  1433.       Exit;
  1434.     end;
  1435.  
  1436.     {Allocate file size array}
  1437.     GetMem(MergeFileSizeP, SizeBufSize);
  1438.  
  1439.     {Compute size of initial merge files}
  1440.     RecordsLeft := NumRecs;
  1441.     MergeFileCount := 0;
  1442.     while RecordsLeft > 0 do begin
  1443.       inc(MergeFileCount);
  1444.       if RecordsLeft >= RunCapacity then
  1445.         RecordsInFile := RunCapacity
  1446.       else
  1447.         RecordsInFile := RecordsLeft;
  1448.       MergeFileSizeP^[MergeFileCount] := RecordsInFile*RecordLen;
  1449.       dec(RecordsLeft, RecordsInFile);
  1450.     end;
  1451.  
  1452.     {Carry sizes forward to get disk space used}
  1453.     PeakDiskSpace := DiskSpace;
  1454.     MergeFileMerged := 0;
  1455.     while MergeFileCount-MergeFileMerged > MergeOrder do begin
  1456.       MergeOpenCount := 0;
  1457.       OutputSpace := 0;
  1458.       while (MergeOpenCount < MergeOrder) and (MergeFileMerged < MergeFileCount) do begin
  1459.         inc(MergeOpenCount);
  1460.         inc(MergeFileMerged);
  1461.         inc(OutputSpace, MergeFileSizeP^[MergeFileMerged]);
  1462.       end;
  1463.       inc(MergeFileCount);
  1464.       {Save size of output file}
  1465.       MergeFileSizeP^[MergeFileCount] := OutputSpace;
  1466.       {Output file and input files coexist temporarily}
  1467.       inc(DiskSpace, OutputSpace);
  1468.       {Store new peak disk space}
  1469.       if DiskSpace > PeakDiskSpace then
  1470.         PeakDiskSpace := DiskSpace;
  1471.       {Account for deleting input files}
  1472.       dec(DiskSpace, OutputSpace);
  1473.     end;
  1474.     MI.MaxDiskSpace := PeakDiskSpace;
  1475.  
  1476.     FreeMem(MergeFileSizeP, SizeBufSize);
  1477.   end;
  1478.  
  1479. end.
  1480.